home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / MATH.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  3.8 KB  |  123 lines
  1. ; MATH.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*    Extended Arithmetic Routines using Borland C 80x87 & Emulator    *
  12. ;*        Interface done through %escape dispatcher        *
  13. ;*                                    *
  14. ;*----------------------------------------------------------------------*
  15. ;*                                    *
  16. ;* Created by: M. Vuilleumier        Date: Jun 1992            *
  17. ;* Revision history:                            *
  18. ;* - 1987:    first steps by Bob Real                    *
  19. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  20. ;*                                    *
  21. ;*                    ``In nomine omnipotentii dei''    *
  22. ;************************************************************************
  23.  
  24. (define exact? integer?)
  25. (define inexact? float?)
  26.  
  27. (begin
  28.   (define acos)
  29.   (define asin)
  30.   (define atan)
  31.   (define cos)
  32.   (define exp)
  33.   (define expt)
  34.   (define log)
  35.   (define sin)
  36.   (define sqrt)
  37.   (define tan)
  38.   (define pi)
  39. )
  40.  
  41. (letrec
  42.   ((%bad-argument
  43.      (lambda (name arg)
  44.        (%error-invalid-operand name arg)))
  45.  
  46.    (test-escape
  47.      (lambda (name numb)
  48.        (lambda (x)
  49.          (if (not (number? x))
  50.              (%bad-argument name x)
  51.              (%esc numb (float x))))))
  52.  
  53.    (power-loop
  54.      (lambda (x n a)      ; A is initially 1, N is non-negative
  55.        (if (zero? n)
  56.            a
  57.            (power-loop (* x x)
  58.                        (quotient n 2)
  59.                        (if (odd? n) (* a x) a)))))
  60.   )
  61.   (begin
  62.     (set! sqrt
  63.           (lambda (n)
  64.         (define try ((test-escape 'sqrt 23) n))
  65.         (define (iter v)
  66.           (cond ((= (* v v) n) v)
  67.             ((and (< (* v v) n)
  68.               (> (* (+ v 1) (+ v 1)) n))
  69.                      try)
  70.             (else (iter (quotient (+ v (quotient n v)) 2)))))
  71.               (if (float? n)
  72.               try
  73.           (iter (round try)))))
  74.  
  75.     (set! sin (test-escape 'sin 24))
  76.     (set! cos (test-escape 'cos 25))
  77.     (set! tan (test-escape 'tan 26))
  78.     (set! atan
  79.           (lambda (x . z)
  80.             (cond ((not (number? x))
  81.                    (%bad-argument 'atan x))
  82.                   ((null? z)
  83.                    (%esc 27 (float x)))
  84.                   ((not (number? (car z)))
  85.                    (%bad-argument 'atan z))
  86.                   (else
  87.                     (%esc 27 (float x) (float (car z)))))))
  88.  
  89.     (set! acos (test-escape 'acos 28))
  90.     (set! asin (test-escape 'asin 29))
  91.     (set! log
  92.           (lambda (x . base)
  93.             (cond ((or (not (number? x)) (<= x 0))
  94.                    (%bad-argument 'log x))
  95.                   ((null? base)
  96.                    (%esc 30 (float x)))
  97.                   ((eq? (car base) 10)             ;the eq? is deliberate
  98.                    (%esc 31 (float x)))
  99.                   (else
  100.                     (let ((non-e-base (car base)))
  101.                       (if (not (number? non-e-base))
  102.                           (%bad-argument 'log non-e-base)
  103.                           (%esc 32 (float x) (float non-e-base))))))))
  104.  
  105.     (set! exp (test-escape 'exp 33))
  106.     (set! expt
  107.           (lambda (a x)
  108.             (cond ((not (number? a))
  109.                    (%bad-argument 'EXPT a))
  110.                   ((not (number? x))
  111.                    (%bad-argument 'EXPT x))
  112.                   ((and (zero? a) (zero? x) (not (integer? x)))
  113.                    (%bad-argument 'EXPT x))
  114.                   ((zero? x)  (if (integer? a) 1 1.0))
  115.                   ((and (integer? x) 
  116.                         (positive? x)
  117.                         (integer? a)) (power-loop a x 1))
  118.                   (else
  119.                    (%esc 34 (float a) (float x))))))
  120.  
  121.     (set! pi (acos -1))
  122.   ))
  123.